home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / sptmbr16.lha / kcl-patches.lisp < prev    next >
Lisp/Scheme  |  1992-09-02  |  12KB  |  363 lines
  1. ;;;-*-Mode:LISP; Package:(PCL LISP 1000); Base:10; Syntax:Common-lisp -*-
  2. ;;;
  3. ;;; *************************************************************************
  4. ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
  5. ;;; All rights reserved.
  6. ;;;
  7. ;;; Use and copying of this software and preparation of derivative works
  8. ;;; based upon this software are permitted.  Any distribution of this
  9. ;;; software or derivative works must comply with all applicable United
  10. ;;; States export control laws.
  11. ;;; 
  12. ;;; This software is made available AS IS, and Xerox Corporation makes no
  13. ;;; warranty about the software, its performance or its conformity to any
  14. ;;; specification.
  15. ;;; 
  16. ;;; Any person obtaining a copy of this software is requested to send their
  17. ;;; name and post office or electronic mail address to:
  18. ;;;   CommonLoops Coordinator
  19. ;;;   Xerox PARC
  20. ;;;   3333 Coyote Hill Rd.
  21. ;;;   Palo Alto, CA 94304
  22. ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
  23. ;;;
  24. ;;; Suggestions, comments and requests for improvements are also welcome.
  25. ;;; *************************************************************************
  26. ;;;
  27.  
  28.  
  29. (in-package "COMPILER")
  30.  
  31. #+akcl
  32. (eval-when (compile load eval)
  33.  
  34. (when (<= system::*akcl-version* 609)
  35.   (pushnew :pre_akcl_610 *features*))
  36.  
  37. (if (and (boundp 'si::*akcl-version*)
  38.      (>= si::*akcl-version* 604))
  39.     (progn
  40.       (pushnew :turbo-closure *features*)
  41.       (pushnew :turbo-closure-env-size *features*))
  42.     (when (fboundp 'si::allocate-growth) 
  43.       (pushnew :turbo-closure *features*)))
  44.  
  45. ;; patch around compiler bug.
  46. (when (<= si::*akcl-version* 609)
  47.   (let ((vcs "static int Vcs;
  48. "))
  49.     (unless (search vcs compiler::*cmpinclude-string*)
  50.       (setq compiler::*cmpinclude-string*
  51.         (concatenate 'string vcs compiler::*cmpinclude-string*)))))
  52.  
  53. (let ((rset "int Rset;
  54. "))
  55.   (unless (search rset compiler::*cmpinclude-string*)
  56.       (setq compiler::*cmpinclude-string*
  57.         (concatenate 'string rset compiler::*cmpinclude-string*))))
  58.  
  59. (when (get 'si::basic-wrapper 'si::s-data)
  60.   (pushnew :new-kcl-wrapper *features*)
  61.   (pushnew :structure-wrapper *features*))
  62.   
  63. )
  64.  
  65.  
  66. #+akcl
  67. (progn
  68.  
  69. (unless (fboundp 'real-c2lambda-expr-with-key)
  70.   (setf (symbol-function 'real-c2lambda-expr-with-key)
  71.     (symbol-function 'c2lambda-expr-with-key)))
  72.  
  73. (defun c2lambda-expr-with-key (lambda-list body)
  74.   (declare (special *sup-used*))
  75.   (setq *sup-used* t)
  76.   (real-c2lambda-expr-with-key lambda-list body))
  77.  
  78.  
  79. ;There is a bug in the implementation of *print-circle* that
  80. ;causes some akcl debugging commands (including :bt and :bl)
  81. ;to cause the following error when PCL is being used:
  82. ;Unrecoverable error: value stack overflow.
  83.  
  84. ;When a CLOS object is printed, travel_push_object ends up
  85. ;traversing almost the whole class structure, thereby overflowing
  86. ;the value-stack.
  87.  
  88. ;from lsp/debug.lsp.
  89. ;*print-circle* is badly implemented in kcl.
  90. ;it has two separate problems that should be fixed:
  91. ;  1. it traverses the printed object putting all objects found
  92. ;     on the value stack (rather than in a hash table or some
  93. ;     other structure; this is a problem because the size of the value stack
  94. ;     is fixed, and a potentially unbounded number of objects
  95. ;     need to be traversed), and
  96. ;  2. it blindly traverses all slots of any
  97. ;     kind of structure including std-object structures.
  98. ;     This is safe, but not always necessary, and is very time-consuming
  99. ;     for CLOS objects (because it will always traverse every class).
  100.  
  101. ;For now, avoid using *print-circle* T when it will cause problems.
  102.  
  103. (eval-when (compile eval)
  104. (defmacro si::f (op &rest args)
  105.     `(the fixnum (,op ,@ (mapcar #'(lambda (x) `(the fixnum ,x)) args) )))
  106.  
  107. (defmacro si::fb (op &rest args)
  108.     `(,op ,@ (mapcar #'(lambda (x) `(the fixnum ,x)) args) ))
  109. )
  110.  
  111. (defun si::display-env (n env)
  112.   (do ((v (reverse env) (cdr v)))
  113.       ((or (not (consp v)) (si::fb > (fill-pointer si::*display-string*) n)))
  114.     (or (and (consp (car v))
  115.          (listp (cdar v)))
  116.     (return))
  117.     (let ((*print-circle* (can-use-print-circle-p (cadar v))))
  118.       (format si::*display-string* "~s=~s~@[,~]" (caar v) (cadar v) (cdr v)))))
  119.  
  120. (defun si::display-compiled-env ( plength ihs &aux
  121.                       (base (si::ihs-vs ihs))
  122.                       (end (min (si::ihs-vs (1+ ihs)) (si::vs-top))))
  123.   (format si::*display-string* "")
  124.   (do ((i base )
  125.        (v (get (si::ihs-fname ihs) 'si::debug) (cdr v)))
  126.       ((or (si::fb >= i end)(si::fb > (fill-pointer si::*display-string*) plength)))
  127.     (let ((*print-circle* (can-use-print-circle-p (si::vs i))))
  128.     (format si::*display-string* "~a~@[~d~]=~s~@[,~]"
  129.         (or (car v)  'si::loc) (if (not (car v)) (si::f - i base)) (si::vs i)
  130.         (si::fb < (setq i (si::f + i 1)) end)))))
  131.  
  132. (clines "#define objnull_p(x) ((x==OBJNULL)?Ct:Cnil)")
  133. (defentry objnull-p (object) (object "objnull_p"))
  134.  
  135. (defun can-use-print-circle-p (x)
  136.   (catch 'can-use-print-circle-p
  137.     (can-use-print-circle-p1 x nil)))
  138.  
  139. (defun can-use-print-circle-p1 (x so-far)
  140.   (and (not (objnull-p x)) ; because of deficiencies in the compiler, maybe?
  141.        (if (member x so-far)
  142.        (throw 'can-use-print-circle-p t)
  143.        (let ((so-far (cons x so-far)))
  144.          (flet ((can-use-print-circle-p (x)
  145.               (can-use-print-circle-p1 x so-far)))
  146.            (typecase x
  147.          (vector  (or (not (eq 't (array-element-type x)))
  148.                   (every #'can-use-print-circle-p x)))
  149.          (cons    (and (can-use-print-circle-p (car x))
  150.                    (can-use-print-circle-p (cdr x))))
  151.          (array   (or (not (eq 't (array-element-type x)))
  152.                   (let* ((rank (array-rank x))
  153.                      (dimensions (make-list rank)))
  154.                 (dotimes (i rank)
  155.                   (setf (nth i dimensions) (array-dimension x i)))
  156.                 (or (member 0 dimensions)
  157.                     (do ((cursor (make-list rank :initial-element 0)))
  158.                     (nil)
  159.                       (declare (:dynamic-extent cursor))
  160.                       (unless (can-use-print-circle-p
  161.                            (apply #'aref x cursor))
  162.                     (return nil))
  163.                       (when (si::increment-cursor cursor dimensions)
  164.                     (return t)))))))
  165.          (t (or (not (si:structurep x))
  166.             (let* ((def (si:structure-def x))
  167.                    (name (si::s-data-name def))
  168.                    (len (si::s-data-length def))
  169.                    (pfun (si::s-data-print-function def)))
  170.               (and (null pfun)
  171.                    (dotimes (i len t)
  172.                  (unless (can-use-print-circle-p
  173.                       (si:structure-ref x name i))
  174.                    (return nil)))))))))))))
  175.  
  176. (defun si::apply-display-fun (display-fun  n lis)  
  177.   (let ((*print-length* si::*debug-print-level*)
  178.     (*print-level* si::*debug-print-level*)
  179.     (*print-pretty* nil)
  180.     (*PRINT-CASE* :downcase)
  181.     (*print-circle* nil)
  182.     )
  183.     (setf (fill-pointer si::*display-string*) 0)
  184.     (format si::*display-string* "{")
  185.     (funcall display-fun n lis)
  186.     (when (si::fb > (fill-pointer si::*display-string*) n)
  187.       (setf (fill-pointer si::*display-string*) n)
  188.       (format si::*display-string* "..."))
  189.  
  190.     (format si::*display-string* "}")
  191.     )
  192.   si::*display-string*
  193.   )
  194.  
  195. ;The old definition of this had a bug:
  196. ;sometimes it returned without calling mv-values.
  197. (defun si::next-stack-frame (ihs &aux line-info li i k na)
  198.   (cond ((si::fb < ihs si::*ihs-base*)
  199.      (si::mv-values nil nil nil nil nil))
  200.     ((let (fun)
  201.        ;; next lower visible ihs
  202.        (si::mv-setq (fun i) (si::get-next-visible-fun ihs))
  203.        (setq na fun)
  204.        (cond ((and (setq line-info (get fun 'si::line-info))
  205.                (do ((j (si::f + ihs 1) (si::f - j 1))
  206.                 (form ))
  207.                ((<= j i) nil)
  208.              (setq form (si::ihs-fun j))
  209.              (cond ((setq li (si::get-line-of-form form line-info))
  210.                 (return-from si::next-stack-frame 
  211.                   (si::mv-values
  212.                    i fun li
  213.                    ;; filename
  214.                    (car (aref line-info 0))
  215.                    ;;environment
  216.                    (list (si::vs (setq k (si::ihs-vs j)))
  217.                      (si::vs (1+ k))
  218.                      (si::vs (+ k 2)))))))))))))
  219.     ((and (not (special-form-p na))
  220.           (not (get na 'si::dbl-invisible))
  221.           (fboundp na))
  222.      (si::mv-values i na nil nil
  223.             (if (si::ihs-not-interpreted-env i)
  224.             nil
  225.             (let ((i (si::ihs-vs i)))
  226.               (list (si::vs i) (si::vs (1+ i)) (si::vs (si::f + i 2)))))))
  227.     (t (si::mv-values nil nil nil nil nil))))
  228. )
  229.  
  230. #+pre_akcl_610
  231. (progn
  232.  
  233. ;(proclaim '(optimize (safety 0) (speed 3) (space 1)))
  234.  
  235. ;Not needed... make-top-level-form generates defuns now.
  236. ;(setq compiler::*compile-ordinaries* t)
  237.  
  238. (eval-when (compile load eval)
  239. (unless (fboundp 'original-co1typep)
  240.   (setf (symbol-function 'original-co1typep) #'co1typep))
  241. )
  242.  
  243. (defun new-co1typep (f args)
  244.   (or (original-co1typep f args)
  245.       (let ((x (car args))
  246.         (type (cadr args)))
  247.     (when (constantp type)
  248.       (let ((ntype (si::normalize-type (eval type))))
  249.         (when (and (eq (car ntype) 'satisfies)
  250.                (cadr ntype)
  251.                (symbolp (cadr ntype))
  252.                (symbol-package (cadr ntype)))
  253.           (c1expr `(the boolean (,(cadr ntype) ,x)))))))))
  254.  
  255. (setf (symbol-function 'co1typep) #'new-co1typep)
  256.  
  257. )
  258.  
  259. #-(or akcl xkcl)
  260. (progn
  261. (in-package 'system)
  262.  
  263. ;;;   This makes DEFMACRO take &WHOLE and &ENVIRONMENT args anywhere
  264. ;;;   in the lambda-list.  The former allows deviation from the CL spec,
  265. ;;;   but what the heck.
  266.  
  267. (eval-when (compile) (proclaim '(optimize (safety 2) (space 3))))
  268.  
  269. (defvar *old-defmacro*)
  270.  
  271. (defun new-defmacro (whole env)
  272.   (flet ((call-old-definition (new-whole)
  273.        (funcall *old-defmacro* new-whole env)))
  274.     (if (not (and (consp whole)
  275.           (consp (cdr whole))
  276.           (consp (cddr whole))
  277.           (consp (cdddr whole))))
  278.     (call-old-definition whole)
  279.     (let* ((ll (caddr whole))
  280.            (env-tail (do ((tail ll (cdr tail)))
  281.                  ((not (consp tail)) nil)
  282.                (when (eq '&environment (car tail))
  283.                  (return tail)))))
  284.       (if env-tail
  285.           (call-old-definition (list* (car whole)
  286.                       (cadr whole)
  287.                       (append (list '&environment
  288.                             (cadr env-tail))
  289.                           (ldiff ll env-tail)
  290.                           (cddr env-tail))
  291.                       (cdddr whole)))
  292.           (call-old-definition whole))))))
  293.  
  294. (eval-when (load eval)
  295.   (unless (boundp '*old-defmacro*)
  296.     (setq *old-defmacro* (macro-function 'defmacro))
  297.     (setf (macro-function 'defmacro) #'new-defmacro)))
  298.  
  299. ;;;
  300. ;;; setf patches
  301. ;;;
  302.  
  303. (defun get-setf-method (form)
  304.   (multiple-value-bind (vars vals stores store-form access-form)
  305.       (get-setf-method-multiple-value form)
  306.     (unless (listp vars)
  307.         (error 
  308.  "The temporary variables component, ~s, 
  309.   of the setf-method for ~s is not a list."
  310.              vars form))
  311.     (unless (listp vals)
  312.         (error 
  313.  "The values forms component, ~s, 
  314.   of the setf-method for ~s is not a list."
  315.              vals form))
  316.     (unless (listp stores)
  317.         (error 
  318.  "The store variables component, ~s,  
  319.   of the setf-method for ~s is not a list."
  320.              stores form))
  321.     (unless (= (list-length stores) 1)
  322.         (error "Multiple store-variables are not allowed."))
  323.     (values vars vals stores store-form access-form)))
  324.  
  325. (defun get-setf-method-multiple-value (form)
  326.   (cond ((symbolp form)
  327.      (let ((store (gensym)))
  328.        (values nil nil (list store) `(setq ,form ,store) form)))
  329.     ((or (not (consp form)) (not (symbolp (car form))))
  330.      (error "Cannot get the setf-method of ~S." form))
  331.     ((get (car form) 'setf-method)
  332.      (apply (get (car form) 'setf-method) (cdr form)))
  333.     ((get (car form) 'setf-update-fn)
  334.      (let ((vars (mapcar #'(lambda (x)
  335.                              (declare (ignore x))
  336.                              (gensym))
  337.                          (cdr form)))
  338.            (store (gensym)))
  339.        (values vars (cdr form) (list store)
  340.                `(,(get (car form) 'setf-update-fn)
  341.              ,@vars ,store)
  342.            (cons (car form) vars))))
  343.     ((get (car form) 'setf-lambda)
  344.      (let* ((vars (mapcar #'(lambda (x)
  345.                               (declare (ignore x))
  346.                               (gensym))
  347.                           (cdr form)))
  348.         (store (gensym))
  349.         (l (get (car form) 'setf-lambda))
  350.         (f `(lambda ,(car l) 
  351.               (funcall #'(lambda ,(cadr l) ,@(cddr l))
  352.                    ',store))))
  353.        (values vars (cdr form) (list store)
  354.            (apply f vars)
  355.            (cons (car form) vars))))
  356.     ((macro-function (car form))
  357.      (get-setf-method-multiple-value (macroexpand-1 form)))
  358.     (t
  359.      (error "Cannot expand the SETF form ~S." form))))
  360.  
  361. )
  362.  
  363.